{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusLite.Geometry
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Objects and operations for 2D geometry.
-- 
--------------------------------------------------------------------------------


module WumpusLite.Geometry
  ( 
    
  -- * Fixed Decimal number - considered to be PostScript point
    Decimal
  , truncateDecimal
  , dtruncFmt

  -- * Radian
  , Radian
  , toRadian
  , fromRadian
  , d2r
  , r2d
  , circularModulo

  -- * Vectors and Points
  , Vec2(..)
  , DVec2
  , Point2(..)
  , DPoint2

  , minPt
  , maxPt
  

  -- * 3x3 Matrix
  , Matrix3'3(..)
  , DMatrix3'3

  , deconsMatrix

  ) where


import WumpusLite.Utils.FormatCombinators

import Data.AffineSpace                         -- package: vector-space
import Data.VectorSpace

import Data.Fixed



-- | Principle numeric type representing PostScript Point.
-- ( approximately a printers point).
--
-- Newtype wrapper over Fixed E9. 
--
newtype Decimal = Decimal { getDecimal :: Fixed E9 }   
  deriving (Eq,Ord,Num,Fractional,Real,RealFrac)

instance Show Decimal where
  showsPrec p d = showsPrec p (getDecimal d)


-- | Truncate the printed decimal representation of a Double.
-- The is prefered to 'showFFloat' from Numeric as it produces
-- shorter representations where appropriate.
-- 
-- 0.000000000 becomes 0.0 rather than however many digs are 
-- specified.
--  
truncateDecimal :: Decimal -> String
truncateDecimal d | abs d < 0.0001  = "0.0"
                  | d < 0.0         = '-' :  show (abs tx)
                  | otherwise       = show tx
  where
    tx :: Double
    tx = (realToFrac (roundi (d*1000000.0))) / 1000000.0

roundi :: RealFrac a => a -> Integer
roundi = round


dtruncFmt :: Decimal -> Doc
dtruncFmt = text . truncateDecimal

--------------------------------------------------------------------------------
-- Radian


-- | Radian is represented with a distinct type. 
--
-- Newtype wrapper over Double.
--
-- Note for Eq and Ord Radian is cast to a Fixed E9.
-- 
newtype Radian = Radian { getRadian :: Double }
  deriving (Num,Floating,Fractional,Real,RealFrac,RealFloat)

instance Show Radian where
  showsPrec i (Radian a) = showsPrec i a


instance Eq Radian where
  (==) a b = toFE9 a == toFE9 b

instance Ord Radian where
  compare a b = toFE9 a `compare` toFE9 b
  (<=) a b    = toFE9 a <= toFE9 b


instance Format Radian where
  format (Radian d) = double d >< text ":rad"


toFE9 :: Radian -> Fixed E9
toFE9 = realToFrac . getRadian


-- | Convert to radians.
--
toRadian :: Real a => a -> Radian 
toRadian = Radian . realToFrac


-- | Convert from radians.
--
fromRadian :: Fractional a => Radian -> a
fromRadian = realToFrac . getRadian


-- | Degrees to radians.
--
-- Degree type fixed to @Double@, compose @d2r@ with @realToFrac@ 
-- for @Float@ etc.
--
d2r :: Double -> Radian
d2r = Radian . realToFrac . (*) (pi/180)

-- | Radians to degrees.
--
-- Degree type fixed to @Double@, compose @r2d@ with @realToFrac@ 
-- for @Float@ etc.
--
r2d :: Radian -> Double
r2d = (*) (180/pi) . fromRadian


-- | Modulo a (positive) angle into the range @0..2*pi@.
--
circularModulo :: Radian -> Radian
circularModulo r = d2r $ dec + (fromIntegral $ i `mod` 360)
  where
    i       :: Integer
    dec     :: Double
    (i,dec) = properFraction $ r2d r

--------------------------------------------------------------------------------
-- Vectors and Points

-- | 2D Vector - both components are strict.
--
-- Note - equality is defined with 'Tolerance' and tolerance is
-- quite high for the usual units. See the note for 'Point2'.
--
data Vec2 u = V2
      { vector_x :: !u
      , vector_y :: !u
      }
  deriving (Eq,Ord,Show)

type DVec2 = Vec2 Decimal



-- | 2D Point - both components are strict.
--
-- Note - equality is defined with 'Tolerance' and tolerance is
-- quite high for the usual units.
--
-- This is useful for drawing, *but* unacceptable data centric
-- work. If more accurate equality is needed define a newtype
-- wrapper over the unit type and make a @Tolerance@ instance with
-- much greater accuracy.
--
data Point2 u = P2
      { point_x    :: !u
      , point_y    :: !u
      }
  deriving (Eq,Ord,Show)

type DPoint2 = Point2 Decimal




-- Functor

instance Functor Vec2 where
  fmap f (V2 a b) = V2 (f a) (f b)


instance Functor Point2 where
  fmap f (P2 a b) = P2 (f a) (f b)


-- Pretty printing

instance Format u => Format (Vec2 u) where
  format (V2 a b) = parens (text "Vec" <+> format a <+> format b)

instance Format u => Format (Point2 u) where
  format (P2 a b) = parens (format a >< comma <+> format b)



--------------------------------------------------------------------------------
-- Vector space instances


-- | Helper.
--
lift2Vec2 :: (u -> u -> u) -> Vec2 u -> Vec2 u -> Vec2 u
lift2Vec2 op (V2 x y) (V2 x' y') = V2 (x `op` x') (y `op` y')


instance Num u => AdditiveGroup (Vec2 u) where
  zeroV = V2 0 0
  (^+^) = lift2Vec2 (+)  
  negateV = fmap negate 


instance Num u => VectorSpace (Vec2 u) where
  type Scalar (Vec2 u) = u
  s *^ v = fmap (s*) v


-- scalar (dot / inner) product via the class InnerSpace
--
-- This definition mandates UndecidableInstances, but this seems
-- in line with Data.VectorSpace...
--

instance (Num u, InnerSpace u, u ~ Scalar u)
    => InnerSpace (Vec2 u) where
  (V2 a b) <.> (V2 a' b') = (a <.> a') ^+^ (b <.> b')


instance Num u => AffineSpace (Point2 u) where
  type Diff (Point2 u) = Vec2 u
  (P2 a b) .-. (P2 x y)   = V2 (a-x)  (b-y)
  (P2 a b) .+^ (V2 vx vy) = P2 (a+vx) (b+vy)



-- | 'minPt' : @ point1 * point2 -> Point2 @
--
-- Synthetic, /component-wise/ min on points. Standard 'min' and 
-- 'max' via Ord are defined lexographically on pairs, e.g.:
-- 
-- > min (1,2) (2,1) = (1,2)
-- 
-- For Points we want the component-wise min and max, that 
-- potentially synthesizes a new point, e.g:
--
-- > minPt (P2 1 2) (Pt 2 1) = Pt 1 1 
-- > maxPt (P2 1 2) (Pt 2 1) = Pt 2 2
-- 
minPt :: Ord u => Point2 u -> Point2 u -> Point2 u
minPt (P2 x y) (P2 x' y') = P2 (min x x') (min y y')


-- | 'maxPt' : @ point1 * point2 -> Point @
--
-- Synthetic, /component-wise/ max on points.  
--
-- > maxPt (P2 1 2) (Pt 2 1) = Pt 2 2
-- 
maxPt :: Ord u => Point2 u -> Point2 u -> Point2 u
maxPt (P2 x y) (P2 x' y') = P2 (max x x') (max y y')



--------------------------------------------------------------------------------
-- 3x3 matrix

-- | 3x3 matrix, considered to be in row-major form.
-- 
-- > (M3'3 a b c
-- >       d e f
-- >       g h i)
--
-- For instance the rotation matrix is represented as
--
-- >  ( cos(a) -sin(a) 0
-- >    sin(a)  cos(a) 0  
-- >      0         0  1 )
--
-- This seems commplace in geometry texts, but PostScript 
-- represents the @current-transformation-matrix@  in 
-- column-major form.
--
-- The right-most column is considered to represent a
-- coordinate:
--
-- >  ( 1 0 x
-- >    0 1 y  
-- >    0 0 1 ) 
-- >
-- 
-- So a translation matrix representing the displacement in x 
-- of 40 and in y of 10 would be:
--
-- >  ( 1 0 40
-- >    0 1 10  
-- >    0 0 1  ) 
-- >
-- 


data Matrix3'3 u = M3'3 !u !u !u  !u !u !u  !u !u !u
  deriving (Eq)

type DMatrix3'3 = Matrix3'3 Decimal


lift2Matrix3'3 :: (u -> u -> u) -> Matrix3'3 u -> Matrix3'3 u -> Matrix3'3 u
lift2Matrix3'3 op (M3'3 a b c d e f g h i) (M3'3 m n o p q r s t u) =
      M3'3 (a `op` m) (b `op` n) (c `op` o)
           (d `op` p) (e `op` q) (f `op` r)
           (g `op` s) (h `op` t) (i `op` u)



-- Show

instance Show u => Show (Matrix3'3 u) where
  show (M3'3 a b c d e f g h i) = "(M3'3 " ++ body ++ ")" where
    body = show [[a,b,c],[d,e,f],[g,h,i]]

-- Functor

instance Functor Matrix3'3 where
  fmap f (M3'3 m n o   p q r   s t u) =
    M3'3 (f m) (f n) (f o)   (f p) (f q) (f r)   (f s) (f t) (f u)


-- Num



instance Num u => Num (Matrix3'3 u) where
  (+) = lift2Matrix3'3 (+)
  (-) = lift2Matrix3'3 (-)

  (*) (M3'3 a b c d e f g h i) (M3'3 m n o p q r s t u) = 
      M3'3 (a*m+b*p+c*s) (a*n+b*q+c*t) (a*o+b*r+c*u) 
           (d*m+e*p+f*s) (d*n+e*q+f*t) (d*o+e*r+f*u) 
           (g*m+h*p+i*s) (g*n+h*q+i*t) (g*o+h*r+i*u) 
  
  abs    = fmap abs 
  negate = fmap negate
  signum = fmap signum
  fromInteger a = M3'3 a' a' a'  a' a' a'  a' a' a' where a' = fromInteger a 




-- | Destructor for Matrix3'3.
-- 
-- Pattern matching on 6-tuple may be more convenient than using 
-- the Matrix3'3 directly.
--
-- > (M3'3 e0x e1x ox  
-- >       e0y e1y oy  
-- >       _   _   _  ) = (e0x,e0y,  e1x,e1y,  ox,oy)
--  
deconsMatrix :: Matrix3'3 u -> (u,u,u,u,u,u)
deconsMatrix (M3'3 e0x e1x ox  
                   e0y e1y oy  
                   _   _   _  ) = (e0x,e0y,  e1x,e1y,  ox,oy)